home *** CD-ROM | disk | FTP | other *** search
/ The Original Shareware 1.1 / The Original Shareware (WeMake CDs)(Volume 1.1)(CDs, Inc)(1993).iso / 19 / tpnet.zip / SAMPLE1.PAS < prev    next >
Pascal/Delphi Source File  |  1987-05-14  |  44KB  |  1,218 lines
  1. { This program has been designed to give developers an  example of how to interface
  2. with the assembly library provided.  The library has been revised and the 
  3. version contained on this disk should be used in place of the original library 
  4. that came with the programmers' guide diskette. The programmers' guide will 
  5. help provide a better understanding of what parameters each call needs and
  6. how each function works.  The following declaration needs to made when ever the 
  7. library routines are accessed, since all function calls are referenced from 
  8. the "xtndopn" function.
  9.                          ALWAYS DECLARE THE FOLLOWING:
  10. function xtndopn(var mode,handle:integer;var filename:str):integer; external 'pasneta'; }
  11.  
  12. {===========================================================================================}
  13.  
  14. program FuncInterface;
  15.     type   str = string[52];
  16.  
  17.     var
  18.          hex,filename,asciiz,sema4,recstr,request,reply: str;
  19.          Handle, retcode, Hoff, Loff, HLen, LLen, FLAG, TMO, Func, Attribute: integer;
  20.          semavalu,Hihandle,Lohandle,opencnt,volume,newserv: integer;
  21.          I, Len, mode, seg, off: integer;
  22.          ans: char;
  23.  
  24.  
  25. procedure Explain;
  26.  
  27.     begin
  28.         writeln('This program will display a menu of different function calls that can be');
  29.         writeln('performed. Each call will prompt the user for the parameters needed by the');
  30.         writeln('function call.  After a function call has completed execution, the user ');
  31.         writeln('must hit the <enter>  key to get back to the main menu.  This program has ');
  32.         writeln('been written to provide examples of how to use the function call interfaces,');
  33.         writeln('contained in pasneta.asm.');
  34.     write('       Type return to continue: ');
  35.         readln;
  36.         clrscr;
  37.     end;
  38.  
  39.  
  40. function HexConvert(num:integer):str;
  41.     var quot, rem: integer;
  42.         dum:str;
  43.  
  44.     begin
  45.         quot:=num div 16;
  46.         rem:= num mod 16;
  47.       
  48.         case rem of
  49.             0:hex:='0'+hex;
  50.             1:hex:='1'+hex;
  51.             2:hex:='2'+hex;
  52.             3:hex:='3'+hex;
  53.             4:hex:='4'+hex;
  54.             5:hex:='5'+hex;
  55.             6:hex:='6'+hex;
  56.             7:hex:='7'+hex;
  57.             8:hex:='8'+hex;
  58.             9:hex:='9'+hex;
  59.             10:hex:='A'+hex;
  60.             11:hex:='B'+hex;
  61.             12:hex:='C'+hex;
  62.             13:hex:='D'+hex;
  63.             14:hex:='E'+hex;
  64.             15:hex:='F'+hex;
  65.         end;
  66.       
  67.         if quot > 15 then 
  68.             dum:=HexConvert(quot)
  69.         else
  70.             begin
  71.                 case quot of
  72.                     0:hex:='0'+hex;
  73.                     1:hex:='1'+hex;
  74.                     2:hex:='2'+hex;
  75.                     3:hex:='3'+hex;
  76.                     4:hex:='4'+hex;
  77.                     5:hex:='5'+hex;
  78.                     6:hex:='6'+hex;
  79.                     7:hex:='7'+hex;
  80.                     8:hex:='8'+hex;
  81.                     9:hex:='9'+hex;
  82.                     10:hex:='A'+hex;
  83.                     11:hex:='B'+hex;
  84.                     12:hex:='C'+hex;
  85.                     13:hex:='D'+hex;
  86.                     14:hex:='E'+hex;
  87.                     15:hex:='F'+hex;
  88.                 end;
  89.             end;
  90.         hexconvert:=hex;
  91.     end;
  92.  
  93.  
  94. procedure get_filename;
  95.     
  96.     begin
  97.         write('Enter the name of the file you want to use:  ');
  98.         readln(filename);
  99.         write('Press the <enter> key to begin .....');
  100.         readln;
  101.         Len:=length(filename);
  102.         filename[Len+1]:=chr(0);        { Make it an ASCIIZ string }
  103.     end;
  104.  
  105.  
  106. (************************************************************************)
  107. (* Open_File is the Novell Extended Open Function Call. It opens the    *)
  108. (* file shareable, read/write.                                          *)
  109. (************************************************************************)
  110. function xtndopn(var mode,handle:integer;var filename:str):integer; external 'pasneta';
  111.  
  112. procedure open;
  113.     
  114.     begin
  115.         get_filename;
  116.         writeln('The file is being opened Sharable Read Write');
  117.         writeln('This is accomplished by placing a hex 42 in the AL register');
  118.         write('Type return to continue......');
  119.     readln;
  120.     flag:=$42;
  121.         clrscr;
  122.         retcode:=xtndopn(flag,handle,filename);
  123.         if retcode <> 0 then 
  124.             writeln('Return code = ',hexconvert(retcode),' file has not been opened')
  125.         else
  126.             begin
  127.                 writeln('The file handle is ',handle,' the return code is : ',retcode);
  128.                 writeln('Remember the file handle number above, it will be needed to release locked records.');
  129.             end;
  130.     end;
  131.  
  132.  
  133. (*************************************************************************)
  134. (* Get or Set file Attributes *)
  135. (*************************************************************************)
  136. function setattr(var FUNC, ATTRIBUTE:integer;var FILENAME:str):integer;external xtndopn[3];
  137.  
  138. procedure setget;
  139.     var get:integer;
  140.  
  141.     begin
  142.         get:=0;
  143.         get_filename;
  144.         writeln('Enter a ''0'' to get the attributes.');
  145.         write('Enter a ''1'' to set the attributes: ');
  146.         readln(func);
  147.         if func = 1 then
  148.             begin
  149.                 writeln('Enter one of the following attributes: ');
  150.                 writeln;
  151.                 writeln('1 - Read only. 2 - Hidden. 4 - system. 128 - Sharable.');
  152.                 readln(attribute);
  153.             end
  154.         else 
  155.             get:=1;
  156.         retcode:=setattr(FUNC,ATTRIBUTE,filename);
  157.         if get = 1 then 
  158.             writeln(' The attribute is : ',hexconvert(attribute));
  159.          writeln('The return code is: ',retcode);
  160.     end;
  161.  
  162. (************************************************************************)
  163. (* Set EOJ flag *)
  164. (************************************************************************)
  165. function eojstat(var flag:integer):integer;external xtndopn[6];
  166.  
  167. procedure SetEOJ;
  168.  
  169.     begin
  170.         writeln('Enter a ''0'' to disable the End Of Job flag.');
  171.     write('Enter a ''1'' to enable the End Of Job flag: ');
  172.         readln(flag);
  173.         retcode:=eojstat(flag);
  174.         writeln('The return code is: ',retcode);
  175.     end;        
  176.  
  177.  
  178. (************************************************************************)
  179. (* Physical record LOG and LOCK  *)
  180. (************************************************************************)
  181. function PRLH_Log(var handle,Hoff,Loff,HLEN,LLEN,Flag,TMO:integer):integer;external xtndopn[9];
  182.  
  183.  
  184. procedure Log_Lock;
  185.     
  186.     begin
  187.         ans:='n';
  188.         write('If the target file is already open, type a ''y'': ');
  189.         readln(ans);
  190.         if ans <> 'y' then 
  191.             OPEN
  192.         else
  193.             begin
  194.                 write('Enter the appropriate file handle: ');
  195.                 readln(handle);
  196.             end;
  197.         write('Enter the Low Word Starting Offset of the record: ');
  198.         readln(Loff);
  199.         write('Enter the High Word Starting Offset of the record: ');
  200.         readln(Hoff);
  201.         write('Enter the Low Word Length of the record: ');
  202.         readln(LLen);
  203.         write('Enter the High Word Length of the record: ');
  204.         readln(HLen);
  205.         write('Enter a ''1'' to lock and log, or enter a ''3'' to do a shared lock: ');
  206.     readln(flag);
  207.        if flag = 1 then
  208.             begin
  209.                  write('Enter the lock timeout in 1/18 secs intervals: ');
  210.                 readln(TMO);
  211.             end;
  212.         retcode:=PRLH_Log(handle,Hoff,Loff,HLen,LLen,Flag,TMO);
  213.         writeln('The return code is: ',retcode);
  214.     end;
  215.  
  216.  
  217. (**************************************************************************)
  218. (* PRLH_Rel  -  Release a record, but it keep it in the log table. *)
  219. (* PRLH_CLr  -  Release a record and remove it from the log table (clear the record).*)
  220. (**************************************************************************)
  221. function PRLH_Rel(var handle,Hoff,Loff,HLEN,LLEN:integer):integer;external xtndopn[12];
  222. function PRLH_Clr(var handle,Hoff,Loff,HLEN,LLEN:integer):integer;external xtndopn[15];
  223.  
  224.  
  225. procedure Rel_Clr;
  226.  
  227.     begin
  228.         ans:='n';
  229.         writeln('To release a record you must have opened the file and obtained a valid file handle.'); 
  230.     write('To proceed type a ''y'': ');
  231.     readln(ans);
  232.         if ans = 'y' then
  233.             begin
  234.                 write('Enter the file handle of the appropriate file: ');
  235.                 readln(handle);
  236.                 write('Enter the Low Word Starting Offset of the record: ');
  237.         readln(Loff);
  238.             write('Enter the High Word Starting Offset of the record: ');
  239.         readln(Hoff);
  240.             write('Enter the Low Word Length of the record: ');
  241.         readln(LLen);
  242.             write('Enter the High Word Length of the record: ');
  243.         readln(HLen);
  244.             write('If you want to release the record, but not remove it from the log table, type an ''r'': ');
  245.             readln(ans);
  246.             if ans ='r' then
  247.                  begin
  248.                       writeln('Releasing the record...');
  249.                   retcode:=PRLH_Rel(handle,Hoff,Loff,HLen,LLen);
  250.                  end
  251.                 else
  252.                  begin
  253.                       writeln('Removing the record from the log table...');
  254.                    retcode:=PRLH_Clr(handle,Hoff,Loff,HLen,LLen);
  255.                  end;
  256.             writeln('The return code is: ',retcode);
  257.             end;
  258.         end;
  259.  
  260.  
  261. (*********************************************************************)
  262. (* PRLS_Lck  -  Lock the record set (all records in the log table *)
  263. (* PRLS_Rel  -  Release record set  *)
  264. (* PRLS_Clr     Release, and clear the record set from the log table.*)
  265. (*********************************************************************)
  266. function PRLS_Lck(var flag,TMO:integer):integer;external xtndopn[27];
  267. function PRLS_Rel:integer;external xtndopn[30];
  268. function PRLS_Clr:integer;external xtndopn[33];
  269.  
  270.  
  271. procedure Lock_Set;
  272.  
  273.     begin
  274.         write('Enter a ''1'' to do a shared lock, nonexclusive:  ');
  275.         readln(flag);
  276.         write('Enter the timeout amount in 1/18 secs intervals, 0 means no wait: ');
  277.     readln(TMO);
  278.       retcode:=PRLS_Lck(flag,TMO);
  279.       writeln('The return code is: ',retcode);
  280.     end;
  281.  
  282.  
  283.  procedure Set_Rel_Clr;
  284.  
  285.     begin
  286.         ans:='n';
  287.       writeln('To release the entire record set without removing the records');
  288.         write('from the log table, enter an ''r'' : ');
  289.     readln(ans);
  290.         if ans = 'r' then
  291.             begin
  292.                 writeln('Releasing the record set...');
  293.                  retcode:=PRLS_Rel;
  294.             end
  295.        else
  296.             begin
  297.                 write('Removing all records from log table...');
  298.                 retcode:=PRLS_Clr;
  299.             end;
  300.         write('Return code is : ',retcode);
  301.     end;
  302.  
  303.  
  304. (**********************************************************************)
  305. (* Open a Semaphore *)
  306. (**********************************************************************)
  307. function OpenSem(var sema4:str;var semavalu,Hihandle,Lohandle,opencnt:integer):integer;external xtndopn[36];
  308. function ExamSem(var Hihandle,Lohandle,semavalu,opencnt:integer):integer;external xtndopn[39];
  309. function WaitSem(var Hihandle,Lohandle,TMO:integer):integer;external xtndopn[42];
  310. function SigSem(var Hihandle,Lohandle:integer):integer;external xtndopn[45];
  311. function ClosSem(var Hihandle,Lohandle:integer):integer;external xtndopn[48];
  312.  
  313.  
  314. procedure Sem_Open;
  315.  
  316.     begin
  317.         write('Enter the name of the semaphore: ');
  318.     readln(sema4);
  319.         write('Enter the initial semaphore value, it must be positive: ');
  320.     readln(semavalu);
  321.         retcode:=opensem(sema4,semavalu,Hihandle,Lohandle,opencnt);
  322.         writeln;writeln;
  323.         writeln('The return code is : ',retcode);
  324.     writeln('The number of stations using this semaphore is : ',opencnt);
  325.         write('The semaphore handle is : HiPart = ',hexconvert(Hihandle));
  326.         hex:=' ';
  327.         writeln(' LoPart = ',hexconvert(Lohandle));
  328.         writeln('WRITE DOWN THIS HANDLE EXACTLY AS YOU SEE IT, IT WILL BE NEEDED TO ACCESS THIS SEMAPHORE');
  329.         writeln;
  330.     end;
  331.  
  332.  
  333. procedure Sem_Exam;
  334.  
  335.     begin
  336.         writeln('When entering the file handle, enter the HEX digits in the following manner: ');
  337.         writeln('    ie.    low part first: $adcb  (put a ''$'' before the hex digits) ');
  338.         writeln;
  339.         write('Enter the semaphore handle, low part first: ');
  340.     readln(Lohandle);
  341.         write('  enter the high part of the handle: ');
  342.     readln(Hihandle);
  343.         retcode:=ExamSem(Hihandle,Lohandle,semavalu,opencnt);
  344.         writeln('The return code is : ',retcode);
  345.         writeln('The open count is : ',opencnt);
  346.         writeln('The semaphore value is : ',semavalu);
  347.     end;
  348.  
  349.  
  350. procedure Sem_Wait_Sig;
  351.  
  352.     begin
  353.         ans:='n';
  354.         writeln('When entering the file handle, enter the HEX digits in the following manner: ');
  355.         writeln('    ie.    low part first: $adcb  (put a ''$'' before the hex digits) ');
  356.         writeln;
  357.         write('Enter the semaphore handle, low part first: ');
  358.     readln(Lohandle);
  359.         write('  enter the high part of the handle: ');
  360.     readln(Hihandle);
  361.         writeln('     If you desire to SIGNAL the semaphore (increment) ');
  362.         write('  enter an ''s'' else type return: ');
  363.         readln(ans);
  364.         if ans = 's' then 
  365.             retcode:= SigSem(Hihandle,Lohandle)
  366.          else
  367.             begin
  368.                 write('Enter the timeout value in 1/18 secs intervals: ');
  369.         readln(TMO);
  370.         writeln;
  371.                 write('waiting... ');
  372.               retcode:=WaitSem(Hihandle,Lohandle,TMO);
  373.             end;
  374.         writeln('The return code is : ',retcode);
  375.     end;
  376.  
  377.  
  378. procedure Sem_Close;
  379.  
  380.     begin
  381.         writeln('When entering the file handle, enter the HEX digits in the following manner: ');
  382.         writeln('    ie.    low part first: $adcb  (put a ''$'' before the hex digits) ');
  383.         writeln;
  384.         write('Enter the semaphore handle, low part first: ');
  385.     readln(Lohandle);
  386.         write('  enter the high part of the handle: ');
  387.     readln(Hihandle);
  388.         retcode:= ClosSem(Hihandle,Lohandle);
  389.         writeln('    closing... the return code is : ',retcode);
  390.     end;
  391.  
  392.  
  393. (************************************************************************)
  394. (* GetOrSet_LockMode sets the Lock Mode to 01 as explained in Function      *)
  395. (* call guide.                                                          *)
  396. (************************************************************************)
  397. function setlck(var func:integer):integer;external xtndopn[51];
  398.  
  399.  
  400. procedure GetOrSet_LockMode;
  401.  
  402.     begin
  403.        writeln('Enter one of the following choices: ');
  404.     writeln;
  405.        writeln('      0 - set to old compatibility mode');
  406.        writeln('      1 - set to new extended locks mode');
  407.        write('      2 - return current lock mode    ---->  ');
  408.     readln(func);
  409.        retcode:=setlck(func);
  410.        writeln('Current lock mode is : ',retcode);
  411.     end;
  412.  
  413.  
  414. (************************************************************************)
  415. (* Transaction Tracking Begin, End, TTS verify, Abort trans,
  416.    Transaction status *)
  417. (************************************************************************)
  418. function BakOuts(var func:integer):integer;external xtndopn[54];
  419.  
  420.  
  421. procedure TTS_functions;
  422.  
  423.     begin
  424.      writeln('Enter a TTS function code');
  425.         writeln('  Enter a ''0'' to begin a transaction'); 
  426.         writeln('  Enter a ''1'' to end a transaction (Note - NO Transaction Reference No. is returned)');
  427.         writeln('  Enter a ''2'' to verify whether or not the preferred file server supports transaction tracking');
  428.         writeln('  Enter a ''3'' to abort a transaction');
  429.        write('  ------> ');
  430.     readln(func);
  431.       retcode:=BakOuts(func);
  432.       writeln('The return code is : ',retcode);
  433.     end;
  434.  
  435.  
  436. (*************************************************************************)
  437. (* Begin or End logical locking read-modify-update cycle *)
  438. (*************************************************************************)
  439. function btrans(var TMO:integer):integer;external xtndopn[57];
  440. function etrans:integer;external xtndopn[60];
  441.  
  442.  
  443. procedure Logical_Begin_End;
  444.  
  445.     begin
  446.       writeln('To begin logical locking enter a ''b''');
  447.         writeln('To end logical locking enter an ''e''');
  448.         write('-------> ');
  449.     readln(ans);
  450.       if ans = 'b' then
  451.            begin
  452.                 ans:='n';
  453.             write('This function assumes that the Lock Mode has been set to 1. If true, type a ''y'' : ');
  454.             readln(ans);
  455.                 if ans = 'y' then
  456.                  begin
  457.                         write('Enter the time out amount in 1/18 secs intervels : ');
  458.             readln(TMO);
  459.                   retcode:=btrans(TMO);
  460.                         write('Logical locking installed');
  461.                  end;
  462.            end
  463.     else
  464.            begin
  465.                 retcode:=etrans;
  466.         write('Logical locking ended');
  467.            end;
  468.       writeln('The return code is : ',retcode);
  469.     end;
  470.         
  471.  
  472. (**************************************************************************)
  473. (* Logical record lock functions--Log, Lock, Unlock, Unlock set, Clear rec,
  474.    Clear set *)
  475. (**************************************************************************)
  476. function reclog(var recstr:str;var flag,TMO:integer):integer;external xtndopn[81];
  477. function reclck(var TMO:integer):integer;external xtndopn[84];
  478. function reculk(var recstr:str):integer;external xtndopn[87];
  479. function reculks:integer;external xtndopn[90];
  480. function recclr(var recstr:str):integer;external xtndopn[93];
  481. function recclrs:integer;external xtndopn[96];
  482.  
  483.  
  484. procedure Logical_locking;
  485.  
  486.     begin
  487.       ans:='n';
  488.       write('This procedure assumes the Lock Mode has been set to 1 if true enter a ''y'': ');
  489.     readln(ans);
  490.       if ans = 'y' then
  491.            begin
  492.             writeln('Choose one of the following functions: ');
  493.             writeln('    0 - Log and Lock a logical record');
  494.             writeln('    1 - Lock all the logical records in the log table');
  495.             writeln('    2 - Release a logical record lock, but do not remove it from the log table');
  496.             writeln('    3 - Release all the logical records in the log table');
  497.             writeln('    4 - Release and remove a logical record it from the log table');
  498.             writeln('    5 - Release and remove the entire logical record set from the log table');
  499.             write(' ----> ');readln(ans);
  500.             if ans ='0' then
  501.                  begin
  502.                   clrscr;
  503.                   writeln('You have chosen to Log and Lock a record ');
  504.             writeln;
  505.                   writeln('Enter a ''1'' to Log and Lock the record (exclusive lock)');
  506.             writeln('Enter a ''3'' to Log and Lock the record  (non-exclusive lock)');
  507.             write('------>');
  508.             readln(flag);
  509.                   write('Enter the record string to lock : ');    
  510.             readln(recstr);
  511.                   write('Enter the time out amount in 1/18 sec intervals : ');
  512.             readln(TMO);
  513.                   retcode:=reclog(recstr,flag,TMO);
  514.                  end
  515.             else if ans = '1' then
  516.                  begin
  517.                   clrscr;
  518.                   writeln('You have chosen to Lock the Record Set ');
  519.                   write('Enter the time out in 1/18 sec intervels : ');    
  520.             readln(TMO);
  521.                   retcode:=reclck(TMO);
  522.                  end
  523.             else if ans = '2' then
  524.                  begin
  525.                   clrscr;
  526.                   writeln('You have chosen to release a record');
  527.                   write('Enter the name of the record string : ');
  528.             readln(recstr);
  529.                   retcode:=reculk(recstr);
  530.                  end
  531.             else if ans = '3' then
  532.                  begin
  533.                   retcode:=reculks;
  534.                   write('Record set released');
  535.                  end
  536.             else if ans = '4' then
  537.                  begin
  538.                   clrscr;
  539.                   writeln('You have chosen to clear a record');
  540.                   write('Enter the name of the record string : ');
  541.             readln(recstr);
  542.                   retcode:=recclr(recstr);
  543.                  end
  544.             else if ans = '5' then
  545.                  begin
  546.                   retcode:=recclrs;
  547.                   write('Record Set Cleared');
  548.                  end;
  549.              writeln('The return code is : ',retcode);
  550.            end;
  551.     end;
  552.  
  553.  
  554. (**********************************************************************)
  555. (* Execute an End Of Job call *)
  556. (**********************************************************************)
  557. function eoj:integer;external xtndopn[99];
  558.  
  559.  
  560. procedure EndOfJob;
  561.  
  562.     begin
  563.     retcode:=eoj;
  564.     writeln('EOJ function call completed');
  565.       writeln('The return code is : ',retcode);
  566.      end;
  567.  
  568.  
  569. (********************************************************************)
  570. (* Logout from the network *)
  571. (********************************************************************)
  572. function sysout:integer;external xtndopn[102];
  573.  
  574. procedure Sys_logout;
  575.  
  576.     begin
  577.     writeln('Executing the logout function call');
  578.       retcode:=sysout;
  579.       writeln('The return code is : ',retcode);
  580.     end;
  581.  
  582.  
  583. (*******************************************************************)
  584. (* Get the volume statistics *)
  585. (*******************************************************************)
  586. function volstat(var volume:integer;var reply:str):integer;external xtndopn[105];
  587.  
  588.  
  589. procedure Get_Vol_Stat;
  590.  
  591.     begin
  592.        write('Enter the volume number : ');
  593.     readln(volume);
  594.     reply:='hi there';
  595.       retcode:=volstat(volume,reply);
  596.       writeln('executing... The return code is : ',retcode);
  597.       writeln;
  598.       writeln('Number of sectors per block : ',ord(reply[1]),ord(reply[2]));
  599.       writeln('Number of total blocks : ',ord(reply[3]),ord(reply[4]));
  600.       writeln('Number of unused blocks : ',ord(reply[5]),ord(reply[6]));
  601.       writeln('Number of directory entries : ',ord(reply[7]),ord(reply[8]));
  602.       writeln('Number of unused directory entries : ',ord(reply[9]),ord(reply[10]));
  603.       write('Volume Name : ',reply[11],reply[12],reply[13],reply[14],reply[15],reply[16]);
  604.       write(reply[17],reply[18],reply[19],reply[20],reply[21],reply[22]);
  605.       writeln(reply[23],reply[24],reply[25],reply[26]);
  606.       writeln('Removeable flag - 00 if volume is not removeable : ',ord(reply[27]),ord(reply[28]));
  607.     end;
  608.  
  609.  
  610. (***********************************************************************)
  611. (* Find number of local disk that the shell has drives mapped to *)
  612. (***********************************************************************)
  613. function locdrv:integer;external xtndopn[108];
  614.  
  615.  
  616. procedure Number_Loc_drv;
  617.     begin
  618.       retcode:=locdrv;
  619.       writeln('Number of local drives : ',retcode);
  620.     end;
  621.  
  622.  
  623. (***********************************************************************)
  624. (* Get the Logical station number *)
  625. (***********************************************************************)
  626. function wsid:integer;external xtndopn[111];
  627.  
  628.  
  629. procedure Logical_Sta_Num;
  630.     begin
  631.       retcode:=wsid;
  632.       writeln('The logical station number is : ',retcode);
  633.     end;
  634.         
  635.  
  636. (*************************************************************************)
  637. (* SetErrorMode sets the Error Mode to 1, so that the program will       *)
  638. (* have control.                                                         *)
  639. (*************************************************************************)
  640. function errmode(var func:integer):integer;external xtndopn[114];
  641.  
  642.  
  643. procedure SetErrorMode;
  644.     begin
  645.        writeln('To set the error mode');
  646.       writeln('Enter one of the following : ');
  647.       writeln('      0 - to display errors on screen');
  648.       writeln('      1 - Extended errors for all file I/O returned in AL');
  649.       writeln('      2 - Critical errors returned in AL (Netware 2.x and up)');
  650.       write('------>  ');
  651.     readln(func);
  652.       retcode:=errmode(func);
  653.       writeln('The previous error mode was : ',retcode);
  654.     end;
  655.  
  656.  
  657. (*************************************************************************)
  658. (* This function allows programs to change the way the shell treats network *)
  659. (* broadcast messages. *)
  660. (*************************************************************************)
  661. function bcsmode(var func:integer):integer;external xtndopn[117];
  662.  
  663.  
  664. procedure Change_Bcast;
  665.  
  666.     begin
  667.       writeln('To set the broadcast mode, choose one of the following : ');
  668.       writeln('       0 - Receive console and workstation broadcasts');
  669.       writeln('       1 - Receive console broadcasts only');
  670.       writeln('       2 - Disable receipt of all broadcasts');
  671.       writeln('       3 - Store broadcast messages');
  672.       writeln('       4 - Return current broadcast mode');
  673.       writeln('       5 - Shell timer interrupt checks are disabled');
  674.       writeln('       6 - Shell timer interrupts are enabled');
  675.       write('---->  ');
  676.     readln(func);
  677.       retcode:=bcsmode(func);
  678.       writeln;
  679.     writeln('The current mode is : ',retcode);
  680.     end;      
  681.  
  682.  
  683. (************************************************************************)
  684. (* The Modify LST Device function enables the use of the network spool device*)
  685. (************************************************************************)
  686. function ctlspl(var func:integer):integer;external xtndopn[120];
  687.  
  688.  
  689. procedure Spool_func;
  690.  
  691.     begin
  692.       writeln('You have chosen to start your spool device, enter one of the following :');
  693.       writeln('       0 - Start the LST catch');
  694.       writeln('       1 - End the LST catch and queue for printing');
  695.       writeln('       2 - End the LST catch and abort print');
  696.       writeln('       3 - Queue for printing and restart LST catch');
  697.       write('---->  ');
  698.     readln(func);
  699.       retcode:=ctlspl(func);
  700.       writeln;
  701.     writeln('The return code is : ',retcode);
  702.     end;
  703.  
  704.  
  705. (*********************************************************************)
  706. (* Spool data to a capture file located on the server *)
  707. (*********************************************************************)
  708. function splreq(var request,reply:str):integer;external xtndopn[123];
  709.  
  710.  
  711. procedure Spool_Capture;
  712.     var packet, tab, copy, prnt, form: integer;
  713.         ban: str;
  714.         res: char;
  715.     
  716.     begin
  717.         ans:='n';
  718.       writeln('Choose one of the following spool functions : ');
  719.       writeln('              0 - Spool data to a capture file on the server');
  720.       writeln('              1 - Close and Queue or Abort the capture file');
  721.       writeln('              2 - Set the spool flags');
  722.       write('---->  ');
  723.     readln(func);
  724.     writeln;
  725.       if func = 0 then
  726.            begin
  727.             writeln('Enter the string to be spooled (length = 1 to 52) :');
  728.               readln(request);
  729.             request:=chr(length(request) + 1) + chr(0) + chr(func) + request;
  730.            end
  731.       else if func = 1 then
  732.            begin
  733.             write('If you want to ABORT the queue type a ''y'' : ');
  734.         readln(ans);
  735.             if ans = 'y' then
  736.                   request:=chr(2) + chr(0) + chr(func) + chr(255)
  737.             else request:=chr(1) + chr(0) + chr(func);
  738.            end
  739.       else if func = 2 then
  740.            begin
  741.             write('Do you want a banner page? (y/n) : ');
  742.         readln(ans);
  743.             if ans = 'y' then 
  744.             packet:=21 
  745.         else packet:=6;
  746.          writeln('Enter the print flags, the choices are: ');
  747.             writeln('    08h - Suppress auto form feed at the end of a print job');
  748.             writeln('    20h - Delete spool file after printing');
  749.             writeln('    40h - Enable tab expansion');
  750.             writeln('    80h - Print a banner page');
  751.             writeln('  example: to suppress form feed and print a banner page add the two numbers');
  752.             writeln('    in HEX --> 008h + 80h = 88h.   TO ENTER --> $88 ($ = HEX) ');
  753.         writeln;
  754.             write('--->  ');
  755.         readln(flag);
  756.         writeln;
  757.             write('Enter the Tab size 1..20 : ');
  758.         readln(tab);
  759.             write('Enter the target printer 0..p : ');
  760.         readln(prnt);
  761.             write('Enter the number of copies to print 0..255 (0 copies = no printing : ');
  762.         readln(copy);
  763.             write('Enter the form type 0..255 : ');
  764.         readln(form);
  765.             write('Enter the string for the banner 1..13 chars : ');
  766.         readln(ban);
  767.             request:=chr(packet)+chr(0)+chr(2)+chr(flag)+chr(tab)+chr(prnt)+chr(copy)+chr(form)+res+ban+chr(0);
  768.         end;
  769.     reply:=chr(0) + chr(0);
  770.       retcode:=splreq(request,reply);
  771.       writeln('The return code is : ',retcode);
  772.     end;
  773.  
  774. (*************************************************************************)
  775. (* Network Communication Function Calls-- Pipes and broadcast *)
  776. (*************************************************************************)
  777. function pipreq(var request,reply:str):integer;external xtndopn[126];
  778.  
  779.  
  780. procedure Pipes;
  781.     var numsta,stanum: integer;
  782.         message: str;
  783.  
  784.     begin
  785.         writeln('Choose one of the following piping functions: ');
  786.       writeln;
  787.       writeln('       0 - Send a broadcast message');
  788.       writeln('       1 - Get a broadcast message');
  789.       writeln('       2 - Disable station broadcasts');
  790.       writeln('       3 - Enable station broadcasts');
  791.       writeln('   Pipe functions can be added, see function call manual');
  792.       writeln;
  793.       write('-----> ');
  794.     readln(func);
  795.     writeln;
  796.       reply:=chr(255)+chr(0);
  797.       if func = 0 then
  798.            begin
  799.             writeln('For our purposes, only one station needs to receive the message ');
  800.             write('Enter the station number: ');
  801.         readln(stanum);
  802.         numsta:=1;
  803.             write('Enter the string you want to send: ');
  804.         readln(message);
  805.             request:= chr(length(message)+4)+chr(0)+chr(0)+chr(numsta)+chr(stanum)+chr(length(message))+message;
  806.             retcode:=pipreq(request,reply);
  807.            end
  808.       else if func = 1 then
  809.            begin
  810.             request:=chr(1)+chr(0)+chr(1);
  811.             retcode:=pipreq(request,reply);
  812.             reply[0]:=chr(ord(reply[3])+3);    { make printable to the screen }
  813.             reply[3]:=chr(0);                  { "       "   "       "     "   "    }
  814.             writeln(reply);
  815.            end
  816.       else if func = 2 then
  817.            begin
  818.             request:=chr(1)+chr(0)+chr(2);
  819.             retcode:=pipreq(request,reply);
  820.            end
  821.       else if func = 3 then
  822.            begin
  823.             request:=chr(1)+chr(0)+chr(3);
  824.             retcode:=pipreq(request,reply);
  825.            end;
  826.       writeln;
  827.       writeln('Error code is: ',retcode);
  828.     end;
  829.  
  830.  
  831. (************************************************************************)
  832. (* Directory Request functions *)
  833. (************************************************************************)
  834. function dpath(var request,reply:str):integer;external xtndopn[129];
  835.  
  836.  
  837. procedure directory;
  838.     var sbase: integer;
  839.  
  840.     begin
  841.       writeln('Get the Base Path Mapping for the entered drive');
  842.       write('Enter a SOURCEBASE (drive handle--1 or 2): ');
  843.     readln(sbase);
  844.       request:=chr(2)+chr(0)+chr(1)+chr(sbase);
  845.       reply:=chr(255)+chr(0);
  846.       retcode:=dpath(request,reply);
  847.       reply[0]:=chr(ord(reply[3])+3);
  848.       reply[3]:=chr(0);
  849.       writeln('Return code is: ',retcode);
  850.       writeln(reply);
  851.     end;
  852.  
  853.  
  854. (*************************************************************************)
  855. (* Log request functions  *)
  856. (**************************************************************************)
  857. function syslog(var request,reply:str):integer;external xtndopn[132];
  858.  
  859.  
  860. procedure SystemLog;
  861.     var connection: integer;
  862.  
  863.     begin
  864.       writeln('Get a Stations Logged Information');
  865.           write('Enter the logical station number or connection number:  ');
  866.       readln(connection);
  867.       request:=chr(2)+chr(0)+chr(5)+chr(connection);
  868.       reply:=chr(255)+chr(1);
  869.       retcode:=syslog(request,reply);
  870.       reply[0]:=chr(255);
  871.       writeln('The return code is: ',retcode);
  872.       writeln('The return string is: ');
  873.       writeln(reply);
  874.     end;
  875.  
  876.  
  877. (************************************************************************)
  878. (* Get the Date/Time String *)
  879. (************************************************************************)
  880. function nettod(var time:str):integer;external xtndopn[144];
  881.  
  882. procedure GetTime;
  883.  
  884.     var time:str;
  885.      begin
  886.             retcode:=nettod(time);  { The value in the str is found at byte#-1 }
  887.           writeln('The return code is: ',retcode);
  888.             writeln('The month/day/year is: ',ord(time[1]),'/',ord(time[2]),'/',ord(time[0]));
  889.             writeln('The time is: ',ord(time[3]),':',ord(time[4]),':',ord(time[5]));
  890.             case ord(time[6]) of
  891.            0:writeln('The day is Sunday');
  892.            1:writeln('The day is Monday');
  893.            2:writeln('The day is Tuesday');
  894.            3:writeln('The day is Wednesday');
  895.            4:writeln('The day is Thursday');
  896.            5:writeln('The day is Friday');
  897.            6:writeln('The day is Saturday');
  898.           end;
  899.      end;
  900.  
  901.  
  902. (*************************************************************************)
  903. (* Get the shell's Base Status *)
  904. (*************************************************************************)
  905. function drvmap(var drive:integer):integer;external xtndopn[150];
  906.  
  907.  
  908. procedure driveHand;
  909.     var drive: integer;
  910.  
  911.     begin
  912.           write('Enter the drive number to check (A = 0, B = 1 etc.): ');
  913.     readln(drive);
  914.       retcode:=drvmap(drive);
  915.       writeln('The network pathbase (drive handle) is: ',retcode);
  916.     end;
  917.  
  918.  
  919. (*************************************************************************)
  920. (* Return the Shell Version *)
  921. (*************************************************************************)
  922. function retshl(var envirstr:str;var mode:integer):integer;external xtndopn[153];
  923.  
  924.  
  925. procedure RetShellVer;
  926.     var envirstr: str;
  927.         mode: integer;
  928.  
  929.     begin
  930.       writeln('Enter the mode:');
  931.     writeln('       0 - Find hardware type only');
  932.       writeln('       1 - get the OS, version and hardware type');
  933.       write('------>  ');
  934.     readln(mode);
  935.       if mode = 0 then
  936.            begin
  937.             retcode:=retshl(envirstr,mode);
  938.             writeln('Hardware type is: ',retcode);
  939.             writeln('The type is defined as follows: 0 - IBM PC, 1 - Victor 9000');
  940.            end
  941.       else
  942.            begin
  943.             retcode:=retshl(envirstr,mode);
  944.             envirstr[0]:=chr(30);
  945.             writeln(envirstr);
  946.            end;
  947.     end;
  948.  
  949.  
  950. (*************************************************************************)
  951. (* Log and/or Lock an ASCIIZ String *)
  952. (*************************************************************************)
  953. function asclog(var flag,timeout:integer;var Asciiz:str):integer;external xtndopn[156];
  954. function asculkf(var Asciiz:str):integer;external xtndopn[159];
  955. function ascclrf(var Asciiz:str):integer;external xtndopn[162];
  956.  
  957.  
  958. procedure AsciizStr;
  959.  
  960.     begin
  961.       writeln('Choose one of the following:');
  962.         writeln('         0 - Log or Lock the Asciiz string');
  963.       writeln('         1 - Release an Asciiz string');
  964.       writeln('         2 - Clear an Asciiz string');
  965.       write('-------> ');
  966.     readln(func);
  967.       writeln;
  968.       if func = 0 then
  969.            begin
  970.             writeln('Type a ''0'' if you only want to log the string');
  971.         writeln('Type a ''1''if you want to log and lock the string');
  972.         write('-------> ');
  973.         readln(flag);
  974.             write('Enter the string name: ');
  975.         readln(asciiz);
  976.             asciiz[length(asciiz)+1]:=chr(0);
  977.             writeln(asciiz);
  978.             write('Enter the desired timeout value in 1/18 second intervals: ');
  979.         readln(TMO);
  980.             writeln;
  981.             retcode:=asclog(flag,TMO,asciiz);
  982.             end
  983.       else if func = 1 then
  984.            begin
  985.             write('Enter the name of the string to be released: ');
  986.         readln(asciiz);
  987.             asciiz[length(asciiz)+1]:=chr(0);   { Make an asciiz string }
  988.             retcode:=asculkf(asciiz);
  989.            end
  990.       else if func = 2 then
  991.            begin
  992.             write('Enter the name of the string to be cleared: ');
  993.         readln(asciiz);
  994.             asciiz[length(asciiz)+1]:=chr(0);   {Make an asciiz string }
  995.             retcode:=ascclrf(asciiz);
  996.            end;
  997.        writeln('The return code is: ',retcode);
  998.     end;
  999.  
  1000.  
  1001. (************************************************************************)
  1002. (* Get Physical station Number--switch setting on the Network Interface Card*)
  1003. (************************************************************************)
  1004. function get_psn:integer;external xtndopn[165];
  1005.  
  1006. procedure GetPhsNum;
  1007.  
  1008.     begin
  1009.         retcode:=get_psn;
  1010.         writeln('The Physical Station Number is : ',retcode);
  1011.     end;
  1012.  
  1013.  
  1014. (************************************************************************)
  1015. (* Get the Shell table Addresses *)
  1016. (************************************************************************)
  1017. function Get_STA(var mode,seg,off:integer):integer;external xtndopn[168];
  1018.  
  1019.  
  1020. procedure GetShlAdr;
  1021.  
  1022.     begin
  1023.       writeln('Enter one of the following choices: ');
  1024.       writeln('         0 - Get the Drive Handle Table');
  1025.       writeln('         1 - Get the Drive Flag Table');
  1026.       writeln('         2 - Get the Drive Server Table');
  1027.       writeln('         3 - Get the Server Mapping Table');
  1028.       write('----->  ');
  1029.     readln(mode);
  1030.       retcode:=get_sta(mode,seg,off);
  1031.       writeln;
  1032.       writeln('These segment and offset addresses have been displayed in decimal');
  1033.       writeln;
  1034.       writeln('The segment address is: ',seg);
  1035.       writeln('The offset address is: ',off);
  1036.     end;
  1037.  
  1038.  
  1039. (************************************************************************)
  1040. (* Set the preferred File Server *)
  1041. (************************************************************************)
  1042. function SetServ(var mode,newserv:integer):integer; external xtndopn[171];
  1043.  
  1044. procedure PrefServ;
  1045.  
  1046.     begin
  1047.       writeln('Enter one of the following: ');
  1048.       writeln('        0 - Set the preferred file server');
  1049.       writeln('        1 - Get the preferred file server');
  1050.       writeln('        2 - Get the Effective File Server');
  1051.       writeln('        3 - Get the Spooled file server');
  1052.       writeln('        4 - Set the primary file server');
  1053.       writeln('        5 - Get the Primary file server');
  1054.       write('----->  ');
  1055.     readln(mode);
  1056.       writeln;
  1057.       write('Enter the preferred server 1-8:  ');
  1058.     readln(newserv);
  1059.       retcode:=setserv(mode,newserv);
  1060.       writeln('The return code is:  ',retcode);
  1061.     end;
  1062.  
  1063.  
  1064. (************************************************************************)
  1065. (* Attach or Detach to a file server *)
  1066. (************************************************************************)
  1067. function modserv(var mode,newserv:integer):integer;external xtndopn[174];
  1068.  
  1069.  
  1070. procedure AttDetServ;
  1071.  
  1072.     begin
  1073.       writeln('Enter one of the following: ');
  1074.       writeln('       0 - Attach to a specfied server');
  1075.       writeln('       1 - Logout and detach from a specified server');
  1076.       writeln('       2 - Logout but do not detach from a specified server');
  1077.       write('----> ');
  1078.     readln(mode);
  1079.       writeln;
  1080.       write('Enter the specified server numbers 1-8: ');
  1081.     readln(newserv);
  1082.       writeln;
  1083.       retcode:=modserv(mode,newserv);
  1084.       writeln('The return code is: ',retcode);
  1085.     end;
  1086.  
  1087.  
  1088. (*************************************************************************)
  1089.  
  1090.  
  1091. procedure menu;
  1092.     var stop:boolean;
  1093.  
  1094.     begin
  1095.         repeat
  1096.             clrscr;
  1097.             stop:=false;
  1098.             hex:=' ';
  1099.             writeln('Choose one of the following: ');
  1100.             writeln('    0 - Get or Set the lock mode');
  1101.             writeln('    1 - OPEN a file');
  1102.             writeln('    2 - SET or Get a files attributes');
  1103.             writeln('    3 - Check the EOJ status');
  1104.             writeln('    4 - Log and Lock a record');
  1105.             writeln('    5 - Release a locked record');
  1106.             writeln('    6 - Lock a record set, all the records in the stations log table');
  1107.             writeln('    7 - Release a locked record set');
  1108.             writeln('    8 - Open a semaphore');
  1109.             writeln('    9 - Examine a semaphore');
  1110.             writeln('    A - Wait semaphore (decrement value) or Signal semaphore (increment value)');
  1111.             writeln('    B - Close a semaphore');
  1112.             writeln('    C - TTS Functions');
  1113.             writeln('    D - Begin or End logical locking read_modify_update cycle');
  1114.             writeln('    E - Logical locking functions');
  1115.             writeln('    F - Execute an End Of Job');
  1116.             writeln('    G - Logout');
  1117.             writeln('    Z - Quit');
  1118.             writeln;
  1119.             writeln('  ENTER A CORRESPONDING CHARACTER OR TYPE RETURN TO SEE THE REST OF THE MENU ');
  1120.             writeln('******************************************************************************');
  1121.             write('----> ');readln(ans);
  1122.         
  1123.             if NOT (ans IN ['0','1','2','3','4','5','6','7','8','9','a','b','c','d','e','f','g','z','A','B','C','D','E','F','G','Z']) then
  1124.                 begin
  1125.                     clrscr;
  1126.                     writeln('H - Get the volume statistics');
  1127.                     writeln('I - Get the number of local drives');
  1128.                     writeln('J - Get the logical station number');
  1129.                     writeln('K - Set the error mode');
  1130.                     writeln('L - Set the broadcast mode');
  1131.                     writeln('M - Start the spooler under program control');
  1132.                     writeln('N - Various spooling functions');
  1133.                     writeln('O - Piping functions');
  1134.                     writeln('P - Directory Functions');
  1135.                     writeln('Q - Sytem log functions');
  1136.                     writeln('R - Get the Date/Time string');
  1137.                     writeln('S - Get the shells Base Status');
  1138.                     writeln('T - Get the shell version');
  1139.                     writeln('U - Log, Lock, Release and clear an Asciiz string.');
  1140.                     writeln('     Any Asciiz string function are assuming the Lock mode is 1');
  1141.                     writeln('V - Get the Physical Station Number');
  1142.                     writeln('W - Get the shell table addresses');
  1143.                     writeln('X - Get the preferred server, different functions');
  1144.                     writeln('Y - Attach or Detach a specified server');
  1145.                     writeln('Z - Quit');
  1146.                     writeln;
  1147.                     writeln('       ENTER A CORRESPONDING CHARACTER OR TYPE RETURN TO SEE MENU AGAIN...');
  1148.                     writeln('******************************************************************************');
  1149.                     write('------> ');readln(ans);
  1150.                 end;
  1151.         
  1152.                 clrscr;
  1153.  
  1154.                 case ans of
  1155.                     '0':GetOrSet_LockMode;
  1156.                     '1':OPEN;
  1157.                     '2':SETGET;
  1158.                     '3':SetEOJ;
  1159.                     '4':Log_Lock;
  1160.                     '5':Rel_Clr;
  1161.                     '6':Lock_Set;
  1162.                     '7':Set_Rel_Clr;
  1163.                     '8':Sem_Open;
  1164.                     '9':Sem_Exam;
  1165.                     'a', 'A':Sem_Wait_Sig;
  1166.                     'b', 'B':Sem_Close;
  1167.                     'c', 'C':TTS_Functions;
  1168.                     'd', 'D':Logical_Begin_End;
  1169.                     'e', 'E':Logical_Locking;
  1170.                     'f', 'F':EndOfJob;
  1171.                     'g', 'G':Sys_logout;
  1172.                     'h', 'H':Get_Vol_Stat;
  1173.                     'i', 'I':Number_loc_drv;
  1174.                     'j', 'J':Logical_Sta_Num;
  1175.                     'k', 'K':SetErrorMode;
  1176.                     'l', 'L':Change_Bcast;
  1177.                     'm', 'M':Spool_Capture;
  1178.                     'n', 'N':Spool_Capture;
  1179.                     'o', 'O':Pipes;
  1180.                     'p', 'P':Directory;
  1181.                     'q', 'Q':SystemLog;
  1182.                     'r', 'R':GetTime;
  1183.                     's', 'S':DriveHand;
  1184.                     't', 'T':RetShellVer;
  1185.                     'u', 'U':AsciizStr;
  1186.                     'v', 'V':GetPhsNum;
  1187.                     'w', 'W':GetShlAdr;
  1188.                     'x', 'X':PrefServ;
  1189.                     'y', 'Y':AttDetServ;
  1190.                     'z', 'Z':stop:=true;
  1191.                 end;
  1192.    
  1193.                 if stop = FALSE then
  1194.                 begin
  1195.                      writeln;writeln;
  1196.                  write('Type return to continue... ');readln;
  1197.                     end;                
  1198.         until stop = true;
  1199.     end;
  1200.  
  1201.  
  1202.  
  1203. (**************************** MAIN PROGRAM ******************************)
  1204.  
  1205.     begin
  1206.         clrscr;
  1207.         writeln;writeln;writeln;writeln;
  1208.         writeln('                  SAMPLE FUNCTION CALL LIBRARY INTERFACE ');
  1209.         write('         please type return to continue... ');readln;
  1210.         writeln;
  1211.         explain;
  1212.         writeln;writeln;writeln;writeln;
  1213.         func:=1;
  1214.         retcode:=errmode(func);
  1215.         writeln('The ERROR MODE has been set to 1, to proceed type return');readln;writeln;
  1216.         menu;
  1217.     end.
  1218.